home *** CD-ROM | disk | FTP | other *** search
/ L' Effet Pommier 3 / L'Effet Pommier - Volume 03.iso / Programmation / Alpha ƒ / Tcl / SystemCode / MacPerl.tcl < prev    next >
Text File  |  1996-01-02  |  47KB  |  1,593 lines
  1. #############################################################################
  2. # MacPerl.tcl
  3. # -----------
  4. #
  5. # This is a set of routines that allow Alpha to act as a front end for the
  6. # standalone MacPerl application and that allow Perl scripts to be used as 
  7. # text filters in Alpha.  These functions are accessed through a special 
  8. # MacPerl menu.
  9. #
  10. # The features of this package are explained in the file "MacPerl Help",
  11. # accessible from the Help menu.
  12. #
  13. #############################################################################
  14. #
  15. # If you don't already have MacPerl, it's available by anonymous ftp from
  16. # the umich site
  17. #
  18. #   mac.archive.umich.edu    [141.211.165.34]    mac/development/languages
  19. #
  20. # and its mirrors.  Also, MacPerl's home site is 
  21. #
  22. #   ftp.switch.ch            [130.59.1.40]        software/mac/src/mpw_c
  23. #
  24. # MacPerl was written (ported to the Mac) by 
  25. #        Matthias Neeracher <neeri@iis.ee.ethz.ch> , and
  26. #        Tim Endres <time@ice.com>.
  27. #
  28. #############################################################################
  29. # Author: W. Thomas Pollard <pollard@chem.columbia.edu>
  30. #
  31. # Version History:
  32. #
  33. # 2.51 1/96  -  Fixed problem w/ "Tell MacPerl:Save As..."
  34. # 2.5  1/96  -  Colorization and cmd-dbl-click modified to support Perl 5 docs
  35. # 2.41 7/95  -  Minor tweaks
  36. # 2.4  7/95  -  Fixed bugs affecting running unsaved scripts and error handling
  37. # 2.3  7/95  -  Minor tweaks and code rearrangement.
  38. # 2.2  6/95  -  Text filters act only on current line if "Apply to Buffer" is
  39. #                  false and no text has been selected.
  40. #               Bug fix in error-marking for scripts sent as AppleEvent params.
  41. #               Cmd-dbl-clicking a function call jumps to function, if
  42. #                  defined in the same file.
  43. # 2.1  6/95  -  Cmd-dbl-clicking a 'require'd filename opens the file.
  44. # 2.0  6/95  -  Minor bug fixes (incl. keyword decapitalization)
  45. #               Alpha 6.0b17 compatibility updates.
  46. #               Text Filters folder is settable from the App Paths menu now.
  47. # 1.9  5/95  -  Cmd-dbl-clicking Perl keywords and special variables displays
  48. #                  the man page info.
  49. # 1.81 4/95  -  one very minor Alpha compatibility update (winInfo->getWinInfo).
  50. # 1.8  4/95  -  Menu reorganized somewhat.
  51. #               Text Filters folder can now be anywhere.
  52. #               "ApplyToBuffer" flag ignored if text has been selected.
  53. #               Bug fixes.
  54. # 1.7  1/95  -  Updated to take advantage of MacPerl 4.1.4 AppleEvent features:
  55. #                1) Text filters use 'batch' doScript (.: STDOUT file obsolete)
  56. #                2) Filter scripts sent as doScript params (.: SCRIPT file obsolete)
  57. #                3) "Save As Droplet" and "Save as Runtime" commands added.
  58. #               Errors generated in 'require'd files are now displayed correctly
  59. # 1.6 10/94  -  "UseDebugger" flag added (forces scripts to run under debugger).
  60. #               Key bindings added for some menu commands.
  61. #               "perlDoScript{,2,3}" procs consolidated into a single proc.
  62. #               "saveAndRun" option added.
  63. #               Command-line args now parsed into units more correctly, in
  64. #                   particular, quoted file names aren't broken up.
  65. #               "Close Output Window" added to "Tell MacPerl" menu.
  66. #               Updated for Alpha 5.98 to load when menu is inserted.
  67. #               The error messages window is now recycled.
  68. #               "perlRecycleOutput" recycles output window.
  69. #               Minor bug fixes.
  70. # 1.5  9/94  -  MacPerl menu rearranged somewhat.
  71. #               Explicit "Get Output Window" command added to menu.
  72. #               Reading "#!" line for args is incompatible w/ standard,
  73. #                   so it's been dropped.
  74. #               Only scan the first 40 output lines for error messages (faster)
  75. #                "wrapFilterScript" no longer opens STDIN
  76. #               Text filters may now use command-line args
  77. #               STDIN for text filters passed as explicit cmd-line arg 
  78. # 1.4  9/94  -  The "#!" line of every script is read for command-line args,
  79. #                    which are passed explicitly to MacPerl with the script.
  80. #                "PromptForArgs" menu flag added.
  81. #                "perlCmdlineArgs" modeVar holds default command-line args.
  82. #                Scripts are sent using custom "perlDoScript2" proc, which
  83. #                    allows passing of explicit command-line args.
  84. # 1.3  9/94  -  When any script generates a compilation error, the file 
  85. #                    containing the script is brought up with the offending 
  86. #                    line highlighted; all error output is also written to
  87. #                    a "Perl Error Messages" window.
  88. #                'repeatLastFilter' runs again the last text-filter script used.
  89. #                'perlLastFilter' modeVar holds pathname of last filter.
  90. #                Menu flags now mirrored as modeVars, so they can be saved and
  91. #                    restored between sessions.
  92. #                Minor bug fixes.
  93. # 1.2  8/94  -  'retrieveOutput' and 'autoSwitch' flags added.
  94. #                'openInMacperl' added.
  95. #                MacPerl output window now closed before new scripts are sent.
  96. #                Filters now abort if there are compilation errors, and
  97. #                MacPerl diagnostic output retrieved and displayed in Alpha.
  98. # 1.1  8/94  -  'quitMacperl' added.
  99. #               perl-mode file-marking updated for Alpha 5.90
  100. #               Simplified installation via 'loadMacperl'(Pete Keleher). 
  101. # 1.0  7/94  -  perl-mode setup updated for Alpha 5.85:
  102. #                    keyword colorization supported
  103. #                    custom file-marking added
  104. #               #! lines in filter scripts now handled correctly 
  105. #               Workarounds installed for AppleEvent bug in MacPerl 4.1.3
  106. # 0.9  3/94  -  perl-mode stuff added, and
  107. #               highlighted 'Perl commands' file (man page) prepared
  108. #               minor bug fixes, too
  109. # 0.8  3/94  -  flags are now check-marked
  110. # 0.7  3/94  -  nested Text Filters folder now supported
  111. #               menu format modified somewhat
  112. # 0.6  3/94  -  'applyToBuffer' flag added
  113. #               scripts in Alpha buffers can now be used as filters 
  114. # 0.5  2/94  -  'filters', 'open special' submenu added
  115. #               'overwrite' flag added
  116. # 0.2  1/94  -  menu support added (Martijn Koster <m.koster@nexor.co.uk>)
  117. #               'execute selection', 'execute buffer' commands added
  118. # 0.1  9/93  -  text filter functionality created
  119. #                  
  120. ##############################################################################
  121. #
  122. proc dummyPerl {} {
  123. }
  124.  
  125. #############################################################################
  126. #  Default settings for the Perl menu flags  
  127. #
  128. set perlDefault(perlUseDebug) 0
  129. set perlDefault(perlGetOutput) 1
  130. set perlDefault(perlAutoSwitch) 1
  131. set perlDefault(perlOverwrite) 0
  132. set perlDefault(perlUsebuffer) 1
  133. set perlDefault(perlPromptArgs) 0
  134. set perlDefault(perlRecycleOutput) 0
  135. set perlDefault(perlPrevScript) {*startup*}
  136. set perlDefault(perlCmdlineArgs) {}
  137. set perlDefault(perlVersion) {4}
  138.  
  139. if {![info exists perlFilterPath]} {
  140.     set perlFilterPath "$HOME:Tcl:UserCode:Text Filters:"
  141. }
  142.  
  143. ##NEW
  144. if {![info exists perlDocs]} {
  145.     set perlDocs "$HOME:Help:Perl Commands"
  146. }
  147. ##
  148.  
  149. foreach var [array names perlDefault] {
  150.     if (![info exists PerlmodeVars($var)]) { 
  151.         set $var $perlDefault($var) 
  152.     } else {
  153.         set $var $PerlmodeVars($var) 
  154.     }
  155. }
  156. unset perlDefault
  157.  
  158. ##############################################################################
  159. # Make duplicate copies of these variables as modeVars, taking responsibility
  160. # for keeping the two sets consistent (argh!)
  161. #
  162. # (Maybe it's OK now to let them _just_ be modeVars, and not also ordinary
  163. # variables?)
  164. #
  165.  
  166. newModeVar Perl perlUseDebug $perlUseDebug 1
  167. newModeVar Perl perlGetOutput $perlGetOutput 1
  168. newModeVar Perl perlAutoSwitch $perlAutoSwitch 1
  169. newModeVar Perl perlOverwrite $perlOverwrite 1
  170. newModeVar Perl perlUsebuffer $perlUsebuffer 1
  171. newModeVar Perl perlPromptArgs $perlPromptArgs 1
  172. newModeVar Perl perlRecycleOutput $perlRecycleOutput 1
  173.  
  174. newModeVar Perl perlLastFilter $perlPrevScript 0
  175. newModeVar Perl perlCmdlineArgs $perlCmdlineArgs 0
  176.  
  177. ##############################################################################
  178. # Other Perl-mode variable definitions
  179. #
  180. newModeVar Perl elecRBrace    {0} 1
  181. newModeVar Perl elecLBrace    {1} 1
  182. newModeVar Perl electricSemi    {0} 1
  183. newModeVar Perl electricTab    {1} 1
  184. newModeVar Perl wordBreak        {(\$)?[a-zA-Z0-9_]+} 0
  185. newModeVar Perl prefixString    {# } 0
  186. newModeVar Perl wordWrap        {0} 1
  187. newModeVar Perl funcExpr        {^sub *([+-a-zA-Z0-9]+)} 0
  188. newModeVar Perl wordBreakPreface        {[^a-zA-Z0-9_\$]} 0
  189. newModeVar Perl autoMark    1    1
  190.  
  191. newModeVar Perl perlVersion $perlVersion 0
  192.  
  193. ##############################################################################
  194. # Miscellaneous definitions
  195. #
  196. set perlErrorWindow {* Perl Error Messages *}
  197. set perlOutputWindow {* Perl Output *}
  198.  
  199. set perlFilterMenu "textFilters"
  200.  
  201. set modeCode ":Tcl:SystemCode:Perl${perlVersion}Mode.tcl"
  202. if {[catch {source $HOME$modeCode}]} {
  203.     alertnote "Couldn't load the Perl-mode colorization file \"$modeCode\".  Contact the maintainer."
  204. }
  205.  
  206. #############################################################################
  207. #  Return paths to standard files, based on the path to MacPerl:
  208. #
  209. proc macperlFolder {} {
  210.    global macperlPath
  211.    regexp {(.*):([^:]*)} $macperlPath pathname dirname filename
  212.    return ${dirname}:
  213. }
  214.  
  215. proc stdinPath {} {
  216.    return [macperlFolder]STDIN
  217. }
  218.  
  219. proc scriptPath {} {
  220.    return [macperlFolder]SCRIPT
  221. }
  222.  
  223. #############################################################################
  224. # Define the dummy proc that will be called when the perl menu
  225. # is first inserted into the menubar
  226. #
  227. proc perlMenu {} {}
  228.  
  229. #############################################################################
  230. #  Build the perl menu
  231. #            
  232. set perlMenu "Ñ132"
  233. set perlOptsMenu "generalOptions"
  234. set filtOptsMenu "filterOptions"
  235.  
  236. menu -n $perlMenu [ concat {
  237.         "/'<Umacperl"
  238.         {menu -m -n "tellMacperl..." -p perlTellProc {
  239.            "/O<UOpen This File"
  240.            "Save As Droplet"
  241.            "Save As Runtime"
  242.            "Save As CGI"
  243.             "(-"
  244.            "Get Output Window"
  245.            "Close Output Window"
  246.            "Quit"
  247.            }
  248.         } 
  249.         "(-"
  250.         "runTheSelection"
  251.         "/R<UrunTheBuffer"
  252.         "/R<B<OsaveAndRun"
  253.         "runAFile"
  254.         "(-"
  255.     } [list [list menu -n $perlFilterMenu {}]] {
  256.        "selectBufferAsFilter"
  257.        "selectFileAsFilter"
  258.        "/F<UrepeatLastFilter"
  259.        "(-" 
  260.     } [list [list menu -n $perlOptsMenu {}]] {
  261.     } [list [list menu -n $filtOptsMenu {}]] {
  262.     } ]
  263.  
  264. enableMenuItem $perlMenu perlDebugWindow 0
  265. enableMenuItem "tellMacperl..." "Save As CGI" 0
  266.  
  267. if {$perlPrevScript == {} || $perlPrevScript == {*startup*}} {
  268.     enableMenuItem $perlMenu repeatLastFilter 0
  269. }
  270.  
  271. # General Perl-menu options menu
  272. #
  273. menu -n $perlOptsMenu {
  274.     "retrieveOutput"
  275.     "autoSwitch"
  276.     "promptForArgs"
  277.     "useDebugger"
  278.     }    
  279. markMenuItem $perlOptsMenu useDebugger $perlUseDebug
  280. markMenuItem $perlOptsMenu retrieveOutput $perlGetOutput
  281. markMenuItem $perlOptsMenu autoSwitch $perlAutoSwitch
  282. markMenuItem $perlOptsMenu promptForArgs $perlPromptArgs
  283.  
  284. # Text Filter options menu
  285. #
  286. menu -n $filtOptsMenu {
  287.     "applyToBuffer"
  288.     "overwriteSelection"
  289.     "(-"
  290.     "textFiltersFolder"
  291.     "rebuildFilterMenu"
  292.     }    
  293. markMenuItem $filtOptsMenu overwriteSelection $perlOverwrite
  294. markMenuItem $filtOptsMenu applyToBuffer $perlUsebuffer
  295.  
  296. # if ([info exists macperlPath]) {
  297. #     rebuildPerlMenu
  298. # }
  299.  
  300. #############################################################################
  301. #  Build a submenu of "preattached" Perl filters using the names of the 
  302. #  scripts in the Text Filters directory.  Called whenever Text Filters
  303. # folder is reassigned.
  304. #
  305. proc rebuildFilterMenu {{args}} {
  306.     global perlFilters perlFilterMenu perlFilterPath
  307.     global $perlFilterMenu
  308.     
  309.     eval [buildSubMenu $perlFilterPath $perlFilterMenu textFiltersProc perlFilters]
  310. }
  311.  
  312. rebuildFilterMenu
  313.  
  314. #############################################################################
  315. # Use variable tracing to keep global vars and modeVars consistent.
  316. #
  317. trace variable PerlmodeVars(perlUseDebug) w shadowPerl
  318. trace variable PerlmodeVars(perlOverwrite) w shadowPerl
  319. trace variable PerlmodeVars(perlUsebuffer) w shadowPerl
  320. trace variable PerlmodeVars(perlGetOutput) w shadowPerl
  321. trace variable PerlmodeVars(perlAutoSwitch) w shadowPerl
  322. trace variable PerlmodeVars(perlPromptArgs) w shadowPerl
  323. trace variable PerlmodeVars(perlLastFilter) w shadowPerl
  324. trace variable PerlmodeVars(perlCmdlineArgs) w shadowPerl
  325. trace variable PerlmodeVars(perlRecycleOutput) w shadowPerl
  326. trace variable PerlmodeVars(perlVersion) w shadowPerl
  327.  
  328. # perlFilterPath is now just a regular variable, set from the App Paths submenu
  329. trace variable perlFilterPath w rebuildFilterMenu
  330.  
  331. # ShadowPerl sets the global vars when the mode vars are modified and
  332. # keeps the menu checkmarked correctly.
  333. #
  334. proc shadowPerl {name1 name2 op} {
  335.     global HOME perlMenu perlOptsMenu filtOptsMenu
  336.     global perlOverwrite perlUsebuffer perlGetOutput perlAutoSwitch
  337.     global perlPromptArgs perlPrevScript perlCmdlineArgs perlUseDebug
  338.     global PerlmodeVars
  339.     if {$name1 == "PerlmodeVars" && $op == "w"} {
  340.         switch $name2 {
  341.             "perlUseDebug"    {
  342.                 set perlUseDebug $PerlmodeVars(perlUseDebug)
  343.                 markMenuItem $perlOptsMenu useDebugger $perlUseDebug
  344.              }
  345.             "perlOverwrite"    {
  346.                 set perlOverwrite $PerlmodeVars(perlOverwrite)
  347.                 markMenuItem $filtOptsMenu overwriteSelection $perlOverwrite
  348.              }
  349.             "perlUsebuffer"    {
  350.                 set perlUsebuffer $PerlmodeVars(perlUsebuffer)
  351.                 markMenuItem $filtOptsMenu applyToBuffer $perlUsebuffer
  352.              }
  353.             "perlGetOutput"    {
  354.                 set perlGetOutput $PerlmodeVars(perlGetOutput)
  355.                 markMenuItem $perlOptsMenu retrieveOutput $perlGetOutput 
  356.             }
  357.             "perlAutoSwitch" {    
  358.                 set perlAutoSwitch $PerlmodeVars(perlAutoSwitch)
  359.                 markMenuItem $perlOptsMenu autoSwitch $perlAutoSwitch 
  360.             }
  361.             "perlPromptArgs" {    
  362.                 set perlPromptArgs $PerlmodeVars(perlPromptArgs)
  363.                 markMenuItem $perlOptsMenu promptForArgs $perlPromptArgs 
  364.             }
  365.             "perlCmdlineArgs" {    
  366.                 set perlCmdlineArgs $PerlmodeVars(perlCmdlineArgs)
  367.             }
  368.             "perlRecycleOutput" {    
  369.                 set perlRecycleOutput $PerlmodeVars(perlRecycleOutput)
  370.             }
  371.             "perlVersion" {    
  372.                 set perlVersion $PerlmodeVars(perlVersion)
  373.                 set modeCode ":Tcl:SystemCode:Perl${perlVersion}Mode.tcl"
  374.                 if {[catch {source $HOME$modeCode}]} {
  375.                     alertnote "Couldn't load the Perl-mode colorization file \"$modeCode\".  Contact the maintainer."
  376.                 }
  377.             }
  378.             "perlLastFilter" {    
  379.                 # Don't allow perlPrevScript to be changed from the flags menu
  380.                 if {$perlPrevScript == "*startup*"} {
  381.                     set perlPrevScript $PerlmodeVars(perlLastFilter)
  382.                     enableMenuItem $perlMenu repeatLastFilter 1
  383.                 } else {
  384.                     set PerlmodeVars(perlLastFilter) $perlPrevScript 
  385.                 }
  386.             }
  387.             default {
  388.                 return
  389.             }
  390.         }
  391.     }
  392. }
  393.  
  394. #############################################################################
  395. # Menu commands
  396. #############################################################################
  397.  
  398. ############################################################################
  399. # Toggle the perl menu flags
  400. #
  401. proc retrieveOutput {} {
  402.     global perlMenu PerlmodeVars perlGetOutput modifiedModeVars
  403.     lappend modifiedModeVars [list perlGetOutput PerlmodeVars]
  404.     if {$perlGetOutput} then {
  405.         set PerlmodeVars(perlGetOutput) 0
  406.     } else {
  407.         set PerlmodeVars(perlGetOutput) 1
  408.     }
  409. }
  410.  
  411. proc useDebugger {} {
  412.     global perlMenu PerlmodeVars perlUseDebug modifiedModeVars
  413.     lappend modifiedModeVars [list  perlUseDebug PerlmodeVars]
  414.     if {$perlUseDebug} then {
  415.         set PerlmodeVars(perlUseDebug) 0
  416.     } else {
  417.         set PerlmodeVars(perlUseDebug) 1
  418.     }
  419. }
  420.  
  421. proc autoSwitch {} {
  422.     global perlMenu PerlmodeVars perlAutoSwitch modifiedModeVars
  423.     lappend modifiedModeVars [list  perlAutoSwitch PerlmodeVars]
  424.     if {$perlAutoSwitch} then {
  425.         set PerlmodeVars(perlAutoSwitch) 0
  426.     } else {
  427.         set PerlmodeVars(perlAutoSwitch) 1
  428.     }
  429. }
  430.  
  431. proc overwriteSelection {} {
  432.     global perlMenu perlOverwrite PerlmodeVars modifiedModeVars
  433.     lappend modifiedModeVars [list  perlOverwrite PerlmodeVars]
  434.     if {$perlOverwrite} then {
  435.         set PerlmodeVars(perlOverwrite) 0
  436.     } else {
  437.         set PerlmodeVars(perlOverwrite) 1
  438.     }
  439. }
  440.  
  441. proc applyToBuffer {} {
  442.     global perlMenu perlUsebuffer PerlmodeVars modifiedModeVars
  443.     lappend modifiedModeVars [list  perlUsebuffer PerlmodeVars]
  444.     if {$perlUsebuffer} then {
  445.            set PerlmodeVars(perlUsebuffer) 0
  446.     } else {
  447.            set PerlmodeVars(perlUsebuffer) 1
  448.     }
  449. }
  450.  
  451. proc promptForArgs {} {
  452.     global perlMenu perlPromptArgs PerlmodeVars modifiedModeVars
  453.     lappend modifiedModeVars [list perlPromptArgs PerlmodeVars]
  454.     if {$perlPromptArgs} then {
  455.            set PerlmodeVars(perlPromptArgs) 0
  456.     } else {
  457.            set PerlmodeVars(perlPromptArgs) 1
  458.     }
  459. }
  460.  
  461. proc textFiltersFolder {} {
  462.     global perlMenu perlFilterPath PerlmodeVars modifiedModeVars pathComments
  463.     
  464.     pathProc {} $pathComments(perlFilterPath)
  465. }
  466.  
  467. #############################################################################
  468. # Switch to MacPerl:
  469. # 
  470. proc macperl {} {
  471.     global macperlPath
  472.     set name [checkRunning MacPerl McPL macperlPath 0]
  473.     if {[string length $name]} {
  474.         switchTo "MacPerl"
  475.     } else {
  476.         alertnote "Couldn't run MacPerl"
  477.     }
  478. }
  479.  
  480. #############################################################################
  481. # Interact with MacPerl in some other way besides executing a script
  482. #
  483. proc perlTellProc {menu name} {
  484.     switch -exact $name {
  485.     "Open This File"        { openInMacperl }
  486.     
  487.     "Save As Droplet"        { saveThruMacperl "droplet" }
  488.     
  489.     "Save As Runtime"        { saveThruMacperl "runtime" }
  490.     
  491.     "Save As CGI"            { saveThruMacperl "cgi" }
  492.     
  493.     "Save As CGI-not"        { saveThruMacperl "cgi-not" }
  494.     
  495.     "Get Output Window"        { openPerlOutput }
  496.     
  497.     "Close Output Window"    { sendCloseWinName MacPerl MacPerl ;
  498.                               sendCloseWinName MacPerl "Perl Debug" }
  499.                             
  500.     "Quit"                    { quitMacperl }
  501.     }
  502. }
  503.  
  504. #############################################################################
  505. # Open the current file under MacPerl.  This used to useful for saving files 
  506. # as droplets or runtime scripts.  Maybe it's still useful for something...?
  507. #
  508. proc openInMacperl {} {
  509.     global macperlPath
  510.     set name [checkRunning MacPerl McPL macperlPath 0]
  511.     if {![string length $name]} {
  512.         alertnote "Couldn't run MacPerl"
  513.     }
  514.  
  515.     if {[winDirty]} {
  516.         case [askyesno -c "Save '[lindex [winNames] 0]'?"] in {
  517.             "yes" {save}
  518.             "no" {}
  519.             "cancel" {return}
  520.         }
  521.     }
  522.     switchTo $name
  523.     sendOpenEvent -n $name [lindex [winNames -f] 0]
  524. }
  525.  
  526. #############################################################################
  527. # Save the script in the current window as a MacPerl droplet or 
  528. # runtime script.  
  529. #
  530. proc saveThruMacperl {type} {
  531.     global macperlPath ALPHA
  532.     set name [checkRunning MacPerl McPL macperlPath 0]
  533.     if {![string length $name]} {
  534.         alertnote "Couldn't run MacPerl"
  535.     }
  536.     
  537.     getWinInfo arr
  538.     if {$arr(dirty) == 1} {
  539.         case [askyesno -c "Save '[lindex [winNames] 0]' source file also?"] in {
  540.             "yes" {save}
  541.             "no" {}
  542.             "cancel" {return}
  543.         }
  544.     }
  545.  
  546.     set destfile [AEFilename [putfile {Save droplet as} [lindex [winNames] 0]]]
  547.  
  548.     set script [curlyq [getText 0 [maxPos]]]
  549.  
  550.     if {$type == "droplet"} {
  551.         set saveType "SCPT"
  552.     } elseif {$type == "runtime"} {
  553.         set saveType "MrP7"
  554.     } elseif {$type == "cgi"} {
  555.         set saveType "WWW╜"
  556.     } elseif {$type == "cgi-not"} {
  557.         set saveType "WWWO"
  558.     } elseif {$type == "text"} {
  559.         set saveType "TEXT"
  560.     }
  561.     
  562.     set err [catch {eval "AEBuild -t 36000 -r \"$name\"" core save {----} [list $script] {dest:} [list $destfile] {fltp:} $saveType } reply ]
  563.     if {$err} { message "AEBuild error code $err in saveThruMacperl" }
  564.     
  565. # The following lines could be used to tell MacPerl to take the script file 
  566. # from an existing disk file and then re-save it in the desired form.
  567. #
  568. #    set srcfile "\[ [AEFilename [lindex [winNames -f] 0]] \]"
  569. #    set reply [eval "AEBuild -t 36000 -r \"$name\"" core save {----} [list $srcfile] {dest:} [list $destfile] {fltp:} $saveType ]
  570. #
  571. }
  572.  
  573. #############################################################################
  574. # Quit a running MacPerl app:
  575. # 
  576. proc quitMacperl {} {
  577.     foreach proc [processes] {
  578.         set sig [lindex $proc 1]
  579.         if {$sig == "McPL"} {
  580.             sendQuitEvent [lindex $proc 0]
  581.             # switchTo is necessary to keep MacPerl from blinking
  582.             switchTo [lindex $proc 0]    
  583.         }
  584.     }
  585. }
  586.  
  587. #############################################################################
  588. # Run the selection as a MacPerl script:
  589. # (No special arrangements are made to provide input or capture the output)
  590. # 
  591. proc runTheSelection {} {
  592.     global scriptFile scriptStart
  593.     set scriptFile [lindex [winNames -f] 0]
  594.     set scriptStart [lindex [posToRowCol [getPos]] 0]
  595.     perlExecuteScript [getSelect]
  596. }
  597.  
  598. proc runTheBuffer {} {
  599.     global scriptFile scriptStart
  600.     set scriptFile [lindex [winNames -f] 0]
  601.     set scriptStart 1
  602.     perlExecuteScript [getText 0 [maxPos]]
  603. }
  604.  
  605. proc runAFile {} {
  606.     global scriptFile scriptStart
  607.     if {! [catch {getfile "Select a Perl script"} path]} {
  608.         set scriptFile $path
  609.         set scriptStart 1
  610.         perlExecuteFile $path
  611.     }
  612. }
  613.  
  614. proc saveAndRun {} {
  615.     global scriptFile scriptStart
  616.     save
  617.     set path [lindex [winNames -f] 0]   
  618.     set scriptFile $path
  619.     set scriptStart 1
  620.     perlExecuteFile $path
  621. }
  622.  
  623. #############################################################################
  624. # Run a preattached Perl text-filter script selected from the menu:
  625. #
  626. proc textFiltersProc {menu name} {
  627.     global perlFilters scriptFile scriptStart
  628.     
  629.     perlFileAsFilter $perlFilters($menu:$name)
  630. }
  631.  
  632. #############################################################################
  633. # Reuse the previous (buffer or file) filter:
  634. #
  635. proc repeatLastFilter {} {
  636.     global scriptFile scriptStart perlPrevScript perlMenu PerlmodeVars
  637.     if {$perlPrevScript != {}} {
  638.         set stype [lindex $perlPrevScript 0]
  639.         set name [lindex $perlPrevScript 1]
  640.         if {$stype == "file"} {
  641.             perlFileAsFilter $name
  642.         } elseif {$stype == "buffer"} {
  643.             perlBufferAsFilter $name
  644.         } else {
  645.             message "Bogus filter name : \"$perlPrevScript\""
  646.             set perlPrevScript {}
  647.             set PerlmodeVars(perlLastFilter) $perlPrevScript 
  648.             enableMenuItem $perlMenu repeatLastFilter 0
  649.         }
  650.     }
  651. }
  652.  
  653. #############################################################################
  654. # Ask for a file containing a Perl script to use as a filter:
  655. #
  656. proc selectFileAsFilter {} {
  657.     global scriptFile scriptStart perlPrevScript
  658.     if {! [catch {getfile "Select a MacPerl script"} path]} {
  659.         perlFileAsFilter $path
  660.     }
  661. }
  662.  
  663. #############################################################################
  664. # Ask for an Alpha buffer containing a Perl script to use as a filter:
  665. #
  666. proc selectBufferAsFilter {} {
  667.     global scriptFile scriptStart perlPrevScript
  668.     
  669.     set windows [winNames]
  670.     set current [lindex $windows 0]
  671.     if {[llength $windows] > 1} {
  672.         set name [listpick [lsort $windows]]
  673.         if {[string length $name]} {
  674.             # get the full name of the chosen window
  675.             set wname [lindex [winNames -f] [lsearch -exact $windows $name]]
  676.             perlBufferAsFilter $wname
  677.            }
  678.     }
  679. }
  680.  
  681. #############################################################################
  682. # Open a file from the MacPerl application folder - used by "Open Special"
  683. #
  684. proc perlOpenFile {menu name} {
  685.     set filename [macperlFolder]$name
  686.     if {[file exists $filename]} {
  687.         edit $filename
  688.     } else {
  689.         alertnote "That file doesn't exist yet"
  690.     }
  691. }
  692.  
  693. #############################################################################
  694. # Support procs
  695. #############################################################################
  696.  
  697. #############################################################################
  698. # Prompt the user to enter a string containing command-line args.
  699. #
  700. proc getCmdlineArgs {} {
  701.     global PerlmodeVars
  702.     set oldargs $PerlmodeVars(perlCmdlineArgs)
  703.     if {![catch {prompt "Command-line arguments (if any):" $oldargs} args]} {
  704.         set PerlmodeVars(perlCmdlineArgs) $args
  705.     } else {
  706.         error "getCmdlineArgs: User cancelled"
  707.     }
  708.     return $args
  709. }
  710.  
  711. #############################################################################
  712. # Tell MacPerl to run a script file:
  713. #
  714. proc perlExecuteFile {path {args {}} {flags {}}} {
  715.     global ALPHA macperlPath
  716.     global perlGetOutput perlAutoSwitch perlPromptArgs perlUseDebug
  717.     global scriptFile scriptStart filterHeadLen
  718.     
  719.     if {[string length $path]} {
  720.         set name [checkRunning MacPerl McPL macperlPath 0]
  721.         if {[string length $name]} {
  722.                 
  723.             set ok [regexp {(.*):([^:]*)} $path pathname dirname filename]
  724.             if {!$ok} {    set name $wname    }
  725.  
  726.             if {$path != [scriptPath]} {    
  727.                 set filterHeadLen 0    
  728.             }
  729.             
  730.             if {$perlUseDebug} {
  731.                 append flags "debug"
  732.             }
  733.             if {$perlPromptArgs} { 
  734.                 append args " [getCmdlineArgs]"
  735.             }
  736.             
  737.             sendCloseWinName MacPerl MacPerl
  738.             sendCloseWinName MacPerl "Perl Debug"
  739.             if {$perlAutoSwitch || $perlUseDebug} then {
  740.                 switchTo $name
  741.             } else {
  742.                 message "Running file \"$filename\" as Perl script"
  743.                 watchCursor
  744.             }
  745.             
  746.             perlDoScript "MacPerl" $path $args {} $flags
  747.             
  748. # (not sure which choice is better...)
  749. #            if {!$perlAutoSwitch} then {switchTo $ALPHA}
  750.             switchTo $ALPHA
  751. #
  752.             if {![getMacPerlError]} {
  753.                 if {$perlGetOutput} then {openPerlOutput}
  754.             }
  755.         } else {
  756.             alertnote "Couldn't run MacPerl"
  757.         }
  758.     } else {
  759.         alertnote "No file specified to execute"
  760.     }
  761. }
  762.  
  763. #############################################################################
  764. # Run a MacPerl script, passed explicitly as a string:
  765. #
  766. # If no "#!/bin/perl" line already exists, one is preprended to the script
  767. # by wrapSelectScript, which also sets $filterHeadLen for use by 
  768. # getMacPerlError.
  769. # 
  770. proc perlExecuteScript {script {args ""} {flags {}} } {
  771.     global macperlPath perlGetOutput perlAutoSwitch perlPromptArgs
  772.     global scriptFile scriptStart filterHeadLen perlUseDebug ALPHA
  773.     
  774.     if {$script != ""} {
  775.         set script [wrapSelectScript $script]
  776.         
  777.         if {![regexp {(.*):([^:]*)} $scriptFile pathname dirname filename]} {
  778.             set filename $scriptFile 
  779.         }
  780.  
  781.         set name [checkRunning MacPerl McPL macperlPath 0]
  782.         if {[string length $name]} {
  783.         
  784.             if {$perlUseDebug} {
  785.                 append flags "debug"
  786.             }
  787.             if {$perlPromptArgs} { 
  788.                 append args " [getCmdlineArgs]"
  789.             }
  790.             
  791.             sendCloseWinName MacPerl MacPerl
  792.             sendCloseWinName MacPerl "Perl Debug"
  793.             if {$perlAutoSwitch || $perlUseDebug} then {
  794.                 switchTo $name
  795.             } else {
  796.                 message "Running buffer \"$filename\" as Perl script"
  797.                 watchCursor
  798.             }
  799.             
  800.             perlDoScript "MacPerl" $script $args {} $flags
  801.             
  802.             switchTo $ALPHA
  803.  
  804.             if {![getMacPerlError]} {
  805.                 if {$perlGetOutput} then {openPerlOutput}
  806.             }
  807.         }
  808.         
  809.     } else {
  810.             alertnote "Can't run an empty script"
  811.     }
  812. }
  813.  
  814. #############################################################################
  815. # Prepare the contents of a disk file for use as a text-filter script. 
  816. # (calls perlTextFilter to actually run the script)
  817. # 
  818. proc perlFileAsFilter {path} {
  819.     global scriptFile scriptStart perlPrevScript perlMenu PerlmodeVars
  820.     
  821.     regexp {(.*):([^:]*)} $path pathname dirname name
  822.     
  823.     if {![catch {readFile $path} coreScript]} {
  824.         set script [wrapFilterScript $coreScript]
  825.         set scriptFile $path
  826.         set scriptStart 1
  827.         set perlPrevScript [list "file" $path]
  828.         set PerlmodeVars(perlLastFilter) $perlPrevScript 
  829.         enableMenuItem $perlMenu repeatLastFilter 1
  830.         message "Running file \"$name\" as text filter ..."
  831.         
  832.         perlTextFilter $script
  833.     } else {
  834.         set perlPrevScript {}
  835.         set PerlmodeVars(perlLastFilter) $perlPrevScript 
  836.         enableMenuItem $perlMenu repeatLastFilter 0
  837.         
  838.         alertnote "Couldn't read the script file : $path"
  839.         return
  840.     }
  841. }
  842.  
  843. #############################################################################
  844. # Prepare the contents of a text window for use as a text-filter script. 
  845. # (calls perlTextFilter to actually run the script)
  846. # 
  847. proc perlBufferAsFilter {wname} {
  848.     global scriptFile scriptStart perlPrevScript perlMenu PerlmodeVars
  849.  
  850.     set ok [regexp {(.*):([^:]*)} $wname pathname dirname name]
  851.     if {!$ok} {    set name $wname    }
  852.     
  853.     if {[lsearch [winNames -f] $wname] >= 0} {
  854.         set coreScript [getText -w $wname 0 [maxPos -w $wname]]
  855.         
  856.         # Does it have any text in it?
  857.         if {[string length $coreScript]} {
  858.             set scriptFile $wname
  859.             set scriptStart 1
  860.             set script [wrapFilterScript $coreScript]
  861.             set perlPrevScript [list "buffer" $wname]
  862.             set PerlmodeVars(perlLastFilter) $perlPrevScript 
  863.             enableMenuItem $perlMenu repeatLastFilter 1
  864.             message "Running buffer \"$name\" as text filter ..."
  865.             
  866.             perlTextFilter $script
  867.         }
  868.     } else {
  869.         set perlPrevScript {}
  870.         set PerlmodeVars(perlLastFilter) $perlPrevScript 
  871.         enableMenuItem $perlMenu repeatLastFilter 0
  872.  
  873.         alertnote "Couldn't find buffer : $name"
  874.     }
  875. }
  876.  
  877. #############################################################################
  878. # Run a Perl script as a command-line text filter, arranging for a text
  879. # buffer to be attached as standard input.  The calling routine should already
  880. # have processed the script with wrapFilterScript.  This routine actually
  881. # send the script and takes care of writing the input and reading the output 
  882. # files.
  883. # 
  884. proc perlTextFilter {script {args {}} {flags {}}} {
  885.     global macperlPath perlOverwrite perlUsebuffer perlPromptArgs
  886.     global filterHeadLen scriptFile scriptStart perlUseDebug ALPHA
  887.     global perlOutputWindow perlRecycleOutput
  888.  
  889.     set name [checkRunning MacPerl McPL macperlPath 0]
  890.     if {![string length $name]} {
  891.         alertnote "Couldn't run MacPerl"
  892.         error "Couldn't run MacPerl"
  893.     }
  894.     writeStdin
  895.  
  896.     if {$perlUseDebug} {
  897.         append flags "debug"
  898.     }
  899.     if {$perlPromptArgs} { 
  900.         append args " [getCmdlineArgs]"
  901.     }
  902.     
  903.     sendCloseWinName MacPerl MacPerl
  904.     sendCloseWinName MacPerl "Perl Debug"
  905.     
  906.     if {$perlUseDebug} then {
  907.         switchTo $name
  908.         perlDoScript "MacPerl" [scriptPath] $args [list [stdinPath]] $flags
  909.         set err [getMacPerlError]
  910.  
  911.     } else {
  912.         watchCursor
  913.         set reply [perlDoScriptBatch "MacPerl" [scriptPath] $args [list [stdinPath]]]
  914.         set err [getBatchError $reply]
  915.     }
  916.     
  917.     switchTo $ALPHA
  918.     
  919.     if {$err == 0} {
  920.         if {$perlUseDebug} {
  921.             set outp [sendGetText MacPerl MacPerl]
  922.         } else {
  923. #            set outp [parseReplyOutp $reply]
  924.             set outp [parseReplyResult $reply]
  925.         }
  926.         pasteFilterResult $outp
  927.     }
  928. }
  929.  
  930.  
  931. #############################################################################
  932. # Check the MacPerl output window for error messages.
  933. #
  934. proc getMacPerlError {} {
  935.     
  936.     set diag [getPerlDiag 40]
  937.     set srcs [parseDiagSrcs $diag]
  938.     set errf [parseDiagErrf $diag]
  939.     set mesg [parseDiagMesg $diag]
  940.  
  941.     if {[string length $errf]} {
  942.         showPerlDiag $diag [string length $diag] $mesg $errf $srcs
  943.         gotoPerlError $errf $srcs $mesg
  944.         return 1
  945.         
  946.     } else {
  947.         return 0
  948.     }
  949. }
  950.  
  951. #############################################################################
  952. # Check the MacPerl batch reply for error messages.
  953. #
  954. proc getBatchError {reply} {
  955.     global perlErrorWindow
  956.     
  957.     set fatalError 0
  958.     set diag [parseReplyDiag $reply]
  959.     set errf [parseDiagErrf  $diag ]
  960.     set srcs [parseReplySrcs $reply]
  961.     set mesg [parseDiagMesg  $diag ]
  962.     set errn [parseReplyErrn $reply]
  963.  
  964.     if {$errn} {        
  965.         showPerlDiag $diag $errn $mesg $errf $srcs
  966.         gotoPerlError $errf $srcs $mesg
  967.         set fatalError 1
  968.         
  969.     } elseif {[string length $diag] > 0} {
  970.         showPerlDiag $diag $errn $mesg $errf $srcs
  971.     }
  972.     
  973.     return $fatalError
  974. }
  975.  
  976. #############################################################################
  977. # Display the Perl diagnostic output in its own window.
  978. #
  979. proc showPerlDiag {diag {errn 1} {mesg {}} {errf {}} {srcs {}}} {
  980.         global perlErrorWindow    
  981.         
  982.         set currWin [lindex [winNames] 0]
  983.         if {[lsearch [winNames] $perlErrorWindow] >= 0} {
  984.             bringToFront $perlErrorWindow
  985.             setWinInfo read-only 0
  986.             deleteText 0 [maxPos] 
  987.             insertText $diag
  988.         } else {
  989.             new -n $perlErrorWindow 
  990.              insertText $diag
  991.         }
  992.         
  993.         goto 0
  994.         catch {shrinkWindow 2}
  995.         setWinInfo dirty 0
  996.         setWinInfo read-only 1
  997.         bringToFront $currWin
  998. }
  999.  
  1000. #############################################################################
  1001. # Bring up a window containing the bug-ridden Perl code and highlight the
  1002. # line at which the error was found.
  1003. #
  1004. proc gotoPerlError {errf srcs {mesg {}}} {
  1005.     global scriptFile scriptStart filterHeadLen
  1006.  
  1007.     if {$errf == [scriptPath] || $errf == "<AppleEvent>"} {
  1008.         set errf $scriptFile
  1009.         # Convert it to the line number in the original file
  1010.         set srcs [expr $srcs + $scriptStart - $filterHeadLen - 1]
  1011.     }
  1012.     # ... and leave an informative error message
  1013.     #
  1014.     if {[string length $mesg]} {
  1015.         set mesg "$mesg at Line $srcs"            
  1016.     } else {
  1017.         set mesg "MacPerl flagged an error at Line $srcs"    
  1018.     }
  1019.     
  1020.     # Bring up the script file and highlight the flagged line
  1021.     #
  1022.     catch {gotoFileLine $errf $srcs $mesg} fname    
  1023. }
  1024.  
  1025. #############################################################################
  1026. # Read the first block of lines (up to a maximum number) from the MacPerl
  1027. # output window.
  1028. #
  1029. proc getPerlDiag {maxlines} {
  1030.     set pat0 {^[ \t]*$}
  1031.  
  1032.     set lines {}    
  1033.  
  1034.     # read first $maxlines of output to the MacPerl window
  1035.     # (faster, but assumes error message won't appear at 
  1036.     # the end of a lot of output).
  1037.     #
  1038.     set nlines [sendCountLines MacPerl MacPerl]
  1039.     set nlines [expr ($nlines > $maxlines)?$maxlines:$nlines]
  1040.     if {$nlines > 0} {
  1041.         set output [sendGetText MacPerl MacPerl 1 $nlines]
  1042.         
  1043.         foreach line [split $output "\r"] {
  1044.             if  {[regexp $pat0 $line mtch]} {
  1045.                 break
  1046.             } else {
  1047.                 append lines "$line\n"
  1048.             }
  1049.         }
  1050.     }
  1051.     return $lines
  1052. }
  1053.  
  1054. #############################################################################
  1055. # Extract various items out of the MacPerl diagnostic output
  1056. #
  1057.  
  1058. # Name of the file in which the error was found
  1059. #
  1060. proc parseDiagErrf {diag}    {
  1061.     if {![regexp {File '([^']+)'; Line} $diag allofit errf]} { 
  1062.         set errf {}
  1063.     }
  1064.     return $errf
  1065. }
  1066.  
  1067. # The line number on which the error was found
  1068. #
  1069. proc parseDiagSrcs {diag}    {
  1070.     if {![regexp {File '[^']+'; Line ([0-9]+)} $diag allofit srcs]} { 
  1071.         set srcs 0 
  1072.     }
  1073.     return $srcs
  1074. }
  1075.  
  1076. # The error message associated with error
  1077. #
  1078. proc parseDiagMesg {diag} {
  1079.     set pat1 {^#(.*)$}
  1080.     set pat2 {File '([^']+)'; Line ([0-9]+)}
  1081.     
  1082.     set errMessage {}
  1083.     set errFound 0
  1084.     
  1085.     foreach line [split $diag "\n"] {
  1086.         if {[regexp $pat2 $line mtch num]} {
  1087.             set errFound 1
  1088.         } elseif {[regexp $pat1 $line mtch err]} {
  1089.             if {$errFound == 0} {
  1090.                 set errMessage $err
  1091.             }
  1092.         }
  1093.     }
  1094.     return $errMessage
  1095. }
  1096.  
  1097. #############################################################################
  1098. # Extract various return parameters out of a MacPerl DoScript reply
  1099. #
  1100.  
  1101. # Result from batch script
  1102. #
  1103. proc parseReplyResult {reply} {
  1104.     if {![regexp {'?\-\-\-\-'?:╥([^╙]*)╙} $reply allofit result]} { 
  1105.         set result {}
  1106.     }
  1107.     return $result
  1108. }
  1109.  
  1110. # Standard output of batch script
  1111. #
  1112. proc parseReplyOutp {reply} {
  1113.     if {![regexp {OUTP:╥([^╙]*)╙} $reply allofit outp]} { 
  1114.         set outp {}
  1115.     }
  1116.     return $outp
  1117. }
  1118.  
  1119. # Diagnostic output of the batch script
  1120. #
  1121. proc parseReplyDiag {reply}    {
  1122.     if {[regexp {diag:╥([^╙]*)╙} $reply allofit diag]}  {
  1123.     } else { 
  1124.         set diag {}
  1125.     }
  1126.     return $diag
  1127. }
  1128.  
  1129. # File alias of the script file in which the error was found
  1130. #
  1131. proc parseReplyErob {reply}    {
  1132.     if {![regexp {erob:alis\(╟(.*)╚\)} $reply allofit erob]} {
  1133.         set erob {} 
  1134.     }
  1135.     return $erob
  1136. }
  1137.  
  1138. # First line flagged in error
  1139. #
  1140. proc parseReplySrcs {reply}    {
  1141.     if {![regexp {erng:{srcs:([0-9]+)[^\}]*}} $reply allofit srcs]} { 
  1142.         set srcs 0 
  1143.     }
  1144.     return $srcs
  1145. }
  1146.  
  1147. # Last line flagged in error
  1148. #
  1149. proc parseReplySrce {reply}    {
  1150.     if {![regexp {erng:{[^\}]*srce:([0-9]+)}} $reply allofit srce]} { 
  1151.         set srce 0
  1152.     }
  1153.     return $srce
  1154. }
  1155.  
  1156. # Error number
  1157. #
  1158. proc parseReplyErrn {reply}    {
  1159.     if {![regexp {errn:([0-9]+)} $reply allofit errn]} {
  1160.         set errn 0
  1161.     }
  1162.     return $errn
  1163. }
  1164.  
  1165. #############################################################################
  1166. #  Take a Perl script and add commands to take the file STDIN as standard
  1167. #  input and STDOUT as standard output.  This allows scripts written as
  1168. #  Unix command-line filters to be used in the (non-MPW) Mac environment as
  1169. #  text filters.
  1170. #
  1171. #  If there's already a #! line in the script, then the new commands
  1172. #  are added after that line.  If there was no #! line in the first place,
  1173. #  one is added, in case MacPerl is set up to require it (can't hurt...) 
  1174. #
  1175. #  $filterHeadLen counts the number of lines we add to the top of the
  1176. #  original script, so that we can allow for it in interpreting error
  1177. #  messages issued by MacPerl.
  1178. #
  1179. #  *** As of MacPerl 4.1.4, this business is pretty much obsolete ***
  1180. #
  1181. proc wrapFilterScript {coreScript} {
  1182.     global filterHeadLen
  1183.  
  1184.     if {[regexp -indices {(#![     !-~]*)} $coreScript allofit cmdln]} {
  1185.         set endPos [lindex $cmdln 1]
  1186.         set filterHead [string range $coreScript 0 [expr $endPos+1]]
  1187.         set coreScript [string range $coreScript [expr $endPos+2] end]
  1188.         set filterHeadLen 0
  1189.     } else {
  1190.         set filterHead "#!/bin/perl\n\r"
  1191.         set filterHeadLen 2
  1192.     }
  1193.         
  1194.     set script $filterHead
  1195.     append script $coreScript
  1196.     
  1197.     # for debugging purposes, save the script on disk
  1198.     #
  1199.     writeScript $script
  1200.     return $script
  1201. }        
  1202.  
  1203. #############################################################################
  1204. #  Add a #!/bin/perl line to the script if it doesn't contain one already.
  1205. #  (MacPerl puts up dialog if this line is missing when it expects it,
  1206. #  hanging the DoScript and leaving us stuck.)
  1207. #
  1208. proc wrapSelectScript {coreScript} {
  1209.     global filterHeadLen
  1210.  
  1211.     if {![regexp -indices {(#![     !-~]*)} $coreScript allofit cmdln]} {
  1212.         set script "#!/bin/perl\r\n"
  1213.         append script $coreScript
  1214.         set filterHeadLen 1
  1215.     } else {
  1216.         set script $coreScript
  1217.         set filterHeadLen 0
  1218.     }
  1219.     
  1220.     # for debugging purposes, save the script on disk
  1221.     #
  1222.     writeScript $script
  1223.     return $script
  1224. }        
  1225.  
  1226. #############################################################################
  1227. #  Paste result of the filter operation in place of the input text, or in
  1228. #  a new window (depending on the flag $perlOverwrite
  1229. #
  1230. proc pasteFilterResult {text} {
  1231.     global perlOverwrite perlRecycleOutput perlOutputWindow
  1232.     global perlUsebuffer 
  1233.     
  1234.     if {!$perlOverwrite} {
  1235.         if {$perlRecycleOutput && 
  1236.             [lsearch [winNames] $perlOutputWindow] >= 0} {                
  1237.             bringToFront $perlOutputWindow
  1238.         } else {
  1239.             new -n $perlOutputWindow
  1240.         }
  1241.     }
  1242.     
  1243.     if {$perlUsebuffer || $perlRecycleOutput} {
  1244.         set from 0
  1245.         set to [maxPos]
  1246.     } else {
  1247.         set from [getPos] 
  1248.         set to [selEnd]
  1249.     }    
  1250.     replaceText $from $to $text
  1251.     
  1252.     if {!$perlOverwrite || $perlUseBuffer} {
  1253.         catch {shrinkWindow 2}
  1254.         goto 0
  1255.     } else {
  1256.         catch shrinkWindow
  1257.         goto $from
  1258.     }
  1259.     if {!$perlOverwrite} { setWinInfo dirty 0 }
  1260. }    
  1261.  
  1262. #############################################################################
  1263. #  Extend the current selection to encompass complete lines.  If the 
  1264. #  'applyToBuffer' flag is checked, then the entire buffer is selected.
  1265. #
  1266. proc completeSelection {} {
  1267.     global perlUsebuffer filterInput
  1268.     set filterInput "buffer \"[lindex [winNames] 0]\""
  1269.     if {$perlUsebuffer} {
  1270.         set start 0
  1271.         set end [maxPos]
  1272.     } else {
  1273.         set start [lineStart [getPos]]
  1274.         set end [nextLineStart [expr [selEnd]-1]]
  1275.         if {$end == $start} { set end [nextLineStart [selEnd]] }
  1276.         
  1277.         set startLine [lindex [posToRowCol $start] 0]
  1278.         set endLine [expr [lindex [posToRowCol $end] 0] - 1]
  1279.         if {$endLine > $startLine+1} {
  1280.             set filterInput "lines $startLine to $endLine of $filterInput"
  1281.         } else {
  1282.             set filterInput "line $startLine of $filterInput"
  1283.         }
  1284.    }
  1285.     return [list $start $end]
  1286. }
  1287.  
  1288. #############################################################################
  1289. #  writeStdin: Extend the selection, as appropriate, and write it to the 
  1290. #     STDIN file in the MacPerl directory.
  1291. #
  1292. #  writeScript: Write the SCRIPT file in the MacPerl directory.  MacPerl will
  1293. #     read the script from this file. 
  1294. #
  1295. proc writeStdin {} {
  1296.     set res [completeSelection]
  1297.     set tmpfid [open [stdinPath] "w+"]
  1298.     puts $tmpfid [eval getText $res]
  1299.     close $tmpfid
  1300. }
  1301.  
  1302. # This is unnecessary now, but maybe it'll still useful to save the script
  1303. # file for debugging.
  1304. #
  1305. proc writeScript {script} {
  1306.     set tmpfid [open [scriptPath] "w+"]
  1307.     puts $tmpfid $script 
  1308.     close $tmpfid
  1309. }
  1310.  
  1311. #############################################################################
  1312. # Read the MacPerl output window and load the contents, if any, into
  1313. # a new Alpha window. 
  1314. #
  1315. proc openPerlOutput {} {
  1316.     global perlRecycleOutput perlOutputWindow
  1317.     
  1318.     set output [sendGetText MacPerl MacPerl]
  1319.     if {[string length $output]} {
  1320.         if {$perlRecycleOutput && 
  1321.             [lsearch [winNames] $perlOutputWindow] >= 0} {
  1322.             
  1323.             bringToFront $perlOutputWindow
  1324.             replaceText 0 [maxPos] $output
  1325.         } else {
  1326.             new -n $perlOutputWindow
  1327.             insertText $output
  1328.         }
  1329.         catch {shrinkWindow 2}
  1330.         setWinInfo dirty 0
  1331.         goto 0
  1332.     }
  1333. }
  1334.  
  1335. #############################################################################
  1336. # translate special DoScript flags into flags string $usrf
  1337. #
  1338. proc perlScriptFlags {{flags {}}} {
  1339.      set usrf {}
  1340.  
  1341.     if {[lsearch -exact $flags "extract"] >= 0} {
  1342.         append usrf { "EXTR" 'true'}
  1343.     } elseif {[lsearch -exact $flags "noextract"] >= 0} {
  1344.         append usrf { "EXTR" 'fals'}
  1345.     }        
  1346.     if {[lsearch -exact $flags "debug"] >= 0} {
  1347.         append usrf { "DEBG" 'true'}
  1348.     } elseif {[lsearch -exact $flags "nodebug"] >= 0} {
  1349.         append usrf { "DEBG" 'fals'}
  1350.     }        
  1351.  
  1352.     if {[lsearch -exact $flags "local"] >= 0} {
  1353.         append usrf { "MODE" 'LOCL'}
  1354.     } elseif {[lsearch -exact $flags "batch"] >= 0} {
  1355.         append usrf { "MODE" 'BATC'}
  1356.     } elseif {[lsearch -exact $flags "remote"] >= 0} {
  1357.         append usrf { "MODE" 'RCTL'}
  1358.     }        
  1359.     return $usrf
  1360. } 
  1361.  
  1362. proc perlScriptArgs {{args {}} {fileargs {}}} {
  1363.     set nargs 0
  1364.     set argv {}
  1365.     
  1366.     foreach item [parseWords $args] {
  1367.         set item [string trim $item]
  1368.         if {[string length $item]} {
  1369.             append argv ", [curlyq $item]"
  1370.             incr nargs
  1371.         }
  1372.     }
  1373.     foreach filename $fileargs {
  1374.         set item [string trim $filename]
  1375.         if {[string length $item]} {
  1376.             append argv ", [curlyq $item]"
  1377.             incr nargs
  1378.         }
  1379.     }
  1380.     return $argv
  1381. }
  1382.  
  1383. #############################################################################
  1384. # General Apple Event routines
  1385. # (most of these have been moved to SystemCode:appleEvents.tcl)
  1386. #
  1387. # DoScript for MacPerl 4.1.3
  1388. # (runs in "Local" mode under v4.1.4+)
  1389. #
  1390. proc perlDoScript {appname script {args {}} {fileargs {}} {flags {}} } {
  1391.     # form list of quoted "command-line" args
  1392.     #
  1393.     if {$script != ""} {
  1394.         set argv "\[[curlyq [string trim $script]]"
  1395. #         foreach item [split [join $args " "] " "] {
  1396. #}
  1397.         append argv [perlScriptArgs $args $fileargs]
  1398.         append argv "]"
  1399.         
  1400.         set usrf [perlScriptFlags $flags]
  1401.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc $usrf \"----\" [list $argv] "]
  1402.     #    alertnote $reply
  1403.     }
  1404. }
  1405.  
  1406. # DoScript for MacPerl 4.1.4+
  1407. #
  1408. proc perlDoScriptBatch {appname script {args {}} {fileargs {}}} {
  1409.     
  1410.     # form list of quoted "command-line" args
  1411.     #
  1412.     if {$script != ""} {
  1413.         set argv "\[[curlyq [string trim $script]]"
  1414.         append argv [perlScriptArgs $args $fileargs ] 
  1415.         append argv "]"
  1416.                 
  1417.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc MODE BATC \"----\" [list $argv]"]
  1418.         
  1419. #         perlDisplayReply $reply
  1420.  
  1421.     } else {
  1422.         set reply {}
  1423.     }
  1424.     return $reply
  1425. }
  1426.  
  1427. # For debugging 
  1428. #
  1429. proc perlDisplayReply {reply} {
  1430.     set currWin [lindex [winNames] 0]
  1431.     new -n {*** DoScript Reply **} 
  1432.     insertText $reply
  1433.         
  1434.     goto 0
  1435.     catch {shrinkWindow 2}
  1436.     setWinInfo dirty 0
  1437.     setWinInfo read-only 1
  1438.     bringToFront $currWin
  1439. }
  1440.  
  1441. # DoScript to launch interactive debugger (for MacPerl 4.1.4+)
  1442. #
  1443. proc perlDoScriptDebug {appname script {args {}} {fileargs {}}} {
  1444.     
  1445.     # form list of quoted "command-line" args
  1446.     #
  1447.     if {$script != ""} {
  1448.         set argv "\[[curlyq [string trim $script]]"
  1449.         append argv [perlScriptArgs "$args debug" $fileargs ] 
  1450.         append argv "]"
  1451.                 
  1452.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc MODE RCTL \"----\" [list $argv]"]
  1453.  
  1454.         new -n {** DoScriptDebug Reply **} 
  1455.         insertText $reply
  1456.             
  1457.         goto 0
  1458.         catch {shrinkWindow 2}
  1459.         setWinInfo dirty 0
  1460.         setWinInfo read-only 1
  1461.  
  1462.  
  1463.     } else {
  1464.         set reply {}
  1465.     }
  1466.     return $reply
  1467. }
  1468.  
  1469. ##############################################################################
  1470. # Automatic indexing of Perl subs
  1471. #
  1472. proc PerlMarkFile {} {
  1473.     set end [maxPos]
  1474.     set pos 0
  1475.     set l {}
  1476.     while {![catch {search -f 1 -r 1 -m 0 -i 0 {^sub} $pos} res]} {
  1477.         set start [lindex $res 0]
  1478.         set end [nextLineStart $start]
  1479.         set text [lindex [getText $start $end] 1]
  1480.         set pos $end
  1481.         set inds($text) [lineStart [expr $start - 1]]
  1482.     }
  1483.  
  1484.     if {[info exists inds]} {
  1485.         foreach f [lsort [array names inds]] {
  1486.             set next [nextLineStart $inds($f)]
  1487.             setNamedMark $f $inds($f) $next $next
  1488.         }
  1489.     }
  1490. }
  1491.  
  1492.  
  1493. # Open a 'require'd Perl file.
  1494. # 
  1495. proc perlFindRequire {from {to 0}} {
  1496.     set reqPat {^[     ]*require[     ]*(\"[^\"]+\"|\'[^\']+\'|[^     ]+)}
  1497.     if {$to == 0} { set to $from }
  1498.     set beg [lineStart $from]
  1499.     set end [nextLineStart $to]
  1500.     set words [parseWords [getText $beg $end]]
  1501.     if {[string tolower [lindex $words 0]] != "require"} {
  1502.         error "Not a require statement"
  1503.     }
  1504.     set root [string trim [lindex $words 1] {'"}]
  1505.     return $root
  1506. }
  1507.  
  1508. proc inlineRequires {} {
  1509.     global lastMatchingLines
  1510.     
  1511.     set reqPat {^[     ]*require[     ]*(\"[^\"]+\"|\'[^\']+\'|[^     ]+)}
  1512.     set pos 0
  1513.     while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $reqPat $pos} mtch]} {
  1514.          [lindex [posToRowCol [lindex $mtch 0]] 0]] 
  1515.         set name [string [eval getText $mtch]
  1516.         set pos [lindex $mtch 1]
  1517.         incr matches
  1518.     }
  1519. }
  1520.  
  1521. # Open a Perl source file. 
  1522. #
  1523. proc openPerlFile {file {extensions {""}}} {
  1524.     global perlSearchPath
  1525.     # Determine absolute file specification
  1526.     # Ignore $extensions if $file already has an extension
  1527.     if {[string length [file extension $file]] == 0} {
  1528.         set extensions {""}
  1529.     }
  1530.     foreach ext $extensions {
  1531.         set filename [absolutePath $file$ext]
  1532.         if {![catch {openFileQuietly $filename}]} {
  1533.             message $filename
  1534.             return 
  1535.         }
  1536.     }
  1537.     if {[llength $perlSearchPath] == 0} { buildPerlSearchPath }
  1538.     foreach folder $perlSearchPath {
  1539.         foreach ext $extensions {
  1540.             set filename "$folder$file$ext"
  1541.             if {![catch {openFileQuietly $filename}]} {
  1542.                 message $filename
  1543.                 return     
  1544.             }
  1545.         }
  1546.     }
  1547.     beep
  1548.     message "can't find Perl source file \"$file\""
  1549. }
  1550.  
  1551. # Return a list of folders in which to search for Perl library files, 
  1552. # including the lib folder in the Perl application directory and the
  1553. # $perlLib folder (if it exists) .  
  1554. # The current folder is not included in the list.
  1555. #
  1556. # (The $perlLib folder is assigned from the AppPaths submenu.)
  1557. #
  1558. proc buildPerlSearchPath {} {
  1559.     global perlLib macperlPath perlSearchPath
  1560.     message "building Perl search path..."
  1561.     set folders {}
  1562.     
  1563.     # The local lib folder:
  1564.     if {[info exists perlLib] && [string length $perlLib] > 0} { 
  1565.         set folders [concat $folders [list $perlLib]]
  1566.         # Search subfolders one level deep:
  1567.         set folders [concat $folders [listSubfolders $perlLib 1]]
  1568.     }
  1569.  
  1570.     # Any "*lib*" folders in the MacPerl application folder:
  1571.     if {[info exists macperlPath] && [string length $macperlPath] > 0} { 
  1572.         set appDir [file dirname $macperlPath]
  1573.         set folders [concat $folders [list $appDir]]
  1574.         # Bug:  'glob' is case sensitive!
  1575.         foreach folder [glob "$appDir:*\[Ll\]ib*"] {
  1576.             set folders [concat $folders [list $folder]]
  1577.             # Search subfolders one level deep:
  1578.             set folders [concat $folders [listSubfolders $folder 1]]
  1579.         }
  1580.     }
  1581.  
  1582.     # Make sure each folder ends with a colon
  1583.     set perlSearchPath {}
  1584.     foreach folder $folders {
  1585.         set folder "[string trimright $folder {:}]:"
  1586.         set perlSearchPath [concat $perlSearchPath [list $folder]]
  1587.     }
  1588. }
  1589.  
  1590. ###########################################################################
  1591.  
  1592.  
  1593.